home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / lisp / lisp-mode.jl < prev    next >
Lisp/Scheme  |  1995-03-09  |  10KB  |  299 lines
  1. ;;;; lisp-mode.jl -- Simple mode for editing Lisp files
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'lisp-mode)
  21.  
  22. (defvar symbol-word-regexps ["[^][()?'\"#; ]" "[][()?'\"#; ]|$"])
  23.  
  24. (defvar lisp-mode-keymap (make-keylist))
  25. (bind-keys lisp-mode-keymap
  26.   "Ctrl-j"    'eval-insert-sexp
  27.   "Meta-Ctrl-x"    'eval-print-sexp
  28.   "TAB"        'indent-line)
  29.  
  30. ;;;###autoload
  31. (defun lisp-mode ()
  32.   "Lisp Mode:\n
  33. Major mode for editing Lisp source. Special commands in this mode are,\n
  34.   `Ctrl-j'        Evaluate the current s-expression as Jade Lisp code
  35.             and insert its value into the current buffer.
  36.   `TAB'            Indent the current line.
  37.   `Ctrl-Meta-x'        Evaluate the current sexp and print its value in
  38.             the status line.
  39.   `Ctrl-Meta-f'        Move to the past the current s-expression.
  40.   `Ctrl-Meta-b'        Move to the beginning of the current sexp.
  41.   `Ctrl-Meta-k'        Kill from the cursor to the end of this sexp.
  42.   `Ctrl-Meta-BS'    Kill from the start of this sexp to the cursor."
  43.   (interactive)
  44.   (when major-mode-kill
  45.     (funcall major-mode-kill (current-buffer)))
  46.   (setq mode-name "Lisp"
  47.     major-mode 'lisp-mode
  48.     major-mode-kill 'lisp-mode-kill
  49.     mode-comment-fun 'lisp-insert-comment
  50.     mode-indent-line 'lisp-indent-line
  51.     mode-forward-exp 'lisp-forward-sexp
  52.     mode-backward-exp 'lisp-backward-sexp
  53.     keymap-path (cons 'lisp-mode-keymap keymap-path))
  54.   (eval-hook 'lisp-mode-hook)
  55.   t)
  56.  
  57. (defun lisp-mode-kill ()
  58.   (setq keymap-path (delq 'lisp-mode-keymap keymap-path)
  59.     major-mode nil
  60.     major-mode-kill nil
  61.     mode-comment-fun nil
  62.     mode-indent-line nil
  63.     mode-forward-exp nil
  64.     mode-backward-exp nil
  65.     mode-name nil)
  66.   t)
  67.  
  68. ;; Now lisp-mode is loaded we may as well make the *jade* buffer use it
  69. (with-buffer default-buffer
  70.   (unless major-mode
  71.     (lisp-mode)))
  72.  
  73. ;;;###autoload
  74. (defun eval-sexp ()
  75.   "Evaluates the Lisp expression before the cursor and returns its value."
  76.   (interactive)
  77.   (goto-char (lisp-backward-sexp))
  78.   (eval (read (current-buffer))))
  79.  
  80. ;;;###autoload
  81. (defun eval-insert-sexp ()
  82.   "Evaluates the Lisp expression before the cursor, then inserts its value
  83. into the buffer."
  84.   (interactive)
  85.   (format (current-buffer) "\n%S\n" (eval-sexp)))
  86.  
  87. ;;;###autoload
  88. (defun eval-print-sexp ()
  89.   "Evaluates the Lisp expression before the cursor, then displays its value
  90. in the status line."
  91.   (interactive)
  92.   (prin1 (eval-sexp) t))
  93.  
  94. (defun lisp-indent-line (&optional pos)
  95.   (unless pos
  96.     (setq pos (cursor-pos)))
  97.   (set-indent-pos (lisp-indent-pos pos)))
  98.  
  99. (defun lisp-insert-comment ()
  100.   (interactive)
  101.   (find-comment-pos)
  102.   (insert ";"))
  103.  
  104.  
  105. ;; Expressions
  106.  
  107. (defun lisp-forward-sexp (&optional number pos)
  108.   "Return the position of the NUMBER'th next s-expression from POS."
  109.   (unless number
  110.     (setq number 1))
  111.   (while (> number 0)
  112.     ;; first, skip empty lines & comments
  113.     (while (looking-at "[\t\f ]*$|[\t\f ]*;.*$" pos)
  114.       (setq pos (next-line 1 (line-start pos)))
  115.       (when (> pos (buffer-end))
  116.     (error "End of buffer")))
  117.     ;; now any other whitespace
  118.     (when (looking-at "[\t\f ]+" pos)
  119.       (setq pos (match-end)))
  120.     (let
  121.         ((c (get-char pos)))
  122.       (cond
  123.        ((= c ?\")
  124.     ;; move over string
  125.     (if (setq pos (find-next-char ?\" (next-char 1 pos)))
  126.         (while (= (get-char (prev-char 1 (copy-pos pos))) ?\\ )
  127.           (unless (setq pos (find-next-char ?\" (next-char 1 pos)))
  128.         (error "String doesn't end!")))
  129.       (error "String doesn't end!"))
  130.     (setq pos (next-char 1 pos)))
  131.        ((member c '(?\( ?\[ ?\<))
  132.     ;; move over brackets
  133.     (unless (setq pos (match-brackets pos))
  134.       (error "Expression doesn't end!"))
  135.     (setq pos (next-char 1 pos)))
  136.        ((member c '(?' ?#))
  137.     ;; iterate one more time
  138.     (setq number (1+ number)
  139.           pos (next-char 1 pos)))
  140.        ((member c '(?\) ?\]))
  141.     (error "End of containing sexp"))
  142.        (t
  143.     ;; a symbol
  144.        (if (looking-at "[^][\t\f ()'\";]+" pos)
  145.        (setq pos (match-end))
  146.      (error "Can't find end of symbol")))))
  147.     (setq number (1- number)))
  148.   pos)
  149.  
  150. (defun lisp-backward-sexp (&optional number orig-pos)
  151.   "Return the position of the NUMBER'th previous s-expression from ORIG-POS."
  152.   (unless number
  153.     (setq number 1))
  154.   (unless orig-pos 
  155.     (setq orig-pos (cursor-pos)))
  156.   (let
  157.       ((pos (copy-pos orig-pos)))
  158.     (while (> number 0)
  159.       ;; skip preceding white space
  160.       (unless (setq pos (find-prev-regexp "[^\t\f ]" (prev-char 1 pos)))
  161.     (error "No expression!"))
  162.       (while (regexp-match-line "^[\f\t ]*;|^[\f\t ]*$" pos)
  163.     (unless (setq pos (prev-line 1 pos))
  164.       (error "Beginning of buffer"))
  165.     (setq pos (line-end pos)))
  166.       (when (if (/= (pos-line orig-pos) (pos-line pos))
  167.         (regexp-match-line "[\f\t ]+;|[\f\t ]*$" pos)
  168.           (regexp-match-line "[\f\t ]+;" pos))
  169.     (setq pos (prev-char 1 (match-start))))
  170.       (let
  171.       ((c (get-char pos)))
  172.     (cond
  173.      ((member c '(?\) ?\] ?\>))
  174.       (unless (setq pos (match-brackets pos))
  175.         (error "Brackets don't match"))
  176.       (when (= c ?\>)
  177.         (prev-char 1 pos)))
  178.      ((= c ?\")
  179.       (if (setq pos (find-prev-char ?\" (prev-char 1 pos)))
  180.           (while (= (get-char (prev-char 1 (copy-pos pos))) ?\\ )
  181.         (unless (setq pos (find-prev-char ?\" (prev-char 1 pos)))
  182.           (error "String doesn't start!")))
  183.         (error "String doesn't start!")))
  184.      ((member c '(?\( ?\[))
  185.       (error "Start of containing sexp"))
  186.      (t
  187.       ;; a symbol?
  188.      (unless (setq pos (find-prev-regexp "[^][\f\t ()'\"]+|^" pos))
  189.        (error "Symbol doesn't start??"))))
  190.     (when (= (get-char (prev-char 1 (copy-pos pos))) ?')
  191.       (setq pos (prev-char 1 pos))
  192.       (when (= (get-char (prev-char 1 (copy-pos pos))) ?#)
  193.         (setq pos (prev-char 1 pos)))))
  194.       (setq number (1- number)))
  195.     pos))
  196.  
  197.  
  198. ;; Indentation
  199.  
  200. (defvar lisp-body-indent 2
  201.   "Number of columns to indent code bodies by.")
  202.  
  203. (defun lisp-indent-pos (&optional line-pos)
  204.   "Returns the correct indentation position for the specified line."
  205.   (unless line-pos
  206.     (setq line-pos (cursor-pos)))
  207.   (let*
  208.       ((pos (line-start line-pos))
  209.        (index 0)
  210.        (sexp-ind (copy-pos pos))
  211.        last-ind
  212.        (form-pos (buffer-end))
  213.        form)
  214.     (if (looking-at "^[\t\f ]*(;;;|;[^;])" pos)
  215.     (set-pos-col sexp-ind (if (looking-at "^[\t\f ]*;;;" pos)
  216.                   0
  217.                 (1- comment-column)))
  218.       ;; Work back to the beginning of the containing sexp. The error-handler
  219.       ;; catches the error that's signalled when the start is reached.
  220.       (error-protect
  221.       (while (setq pos (lisp-backward-sexp 1 pos))
  222.         (when (<= form-pos pos)
  223.           (error "Infinite loop"))
  224.         (when (zerop (pos-col pos))
  225.           (set-pos-col sexp-ind 0)
  226.           (return sexp-ind))
  227.         (setq form-pos pos
  228.           index (1+ index))
  229.         (when (or (null last-ind) (= (pos-line (car last-ind))
  230.                      (pos-line pos)))
  231.           (setq last-ind (cons (char-to-glyph-pos pos) last-ind))))
  232.     (error))
  233.       ;; If there weren't any previous sexps to indent against stop now
  234.       (unless (zerop index)
  235.     (if last-ind
  236.         (setq last-ind (if (and (= (pos-line pos) (pos-line (car last-ind)))
  237.                     (>= (length last-ind) 2))
  238.                    (nth 1 last-ind)
  239.                  (car last-ind)))
  240.       (setq last-ind (copy-pos pos)))
  241.     ;; pos now points to the first sexp in the containing sexp
  242.     (set-pos-col sexp-ind
  243.              (pos-col (char-to-glyph-pos
  244.                    (or (find-prev-regexp "[\(\[]" pos)
  245.                    pos))))
  246.     (setq form-pos (copy-pos pos)
  247.           form (read (cons (current-buffer) form-pos)))
  248.     (when (symbolp form)
  249.       (let
  250.           ((type (get form 'lisp-indent)))
  251.         (cond
  252.          ((null type)
  253.           ;; standard indentation
  254.           (if (= (- (pos-line line-pos) (pos-line pos)) 1)
  255.           ;; on the second line of this sexp
  256.           (if (< index 2)
  257.               (set-pos-col sexp-ind (pos-col (char-to-glyph-pos pos)))
  258.             (when (looking-at "[\t\f ]*" form-pos)
  259.               (set-pos-col sexp-ind
  260.                    (pos-col (char-to-glyph-pos
  261.                          (match-end))))))
  262.         (set-pos-col sexp-ind (pos-col last-ind))))
  263.          ((eq type 'defun)
  264.           ;; defun type indentation
  265.           (if (or (= index 2) (= (- (pos-line line-pos) (pos-line pos)) 1))
  266.           (right-char lisp-body-indent sexp-ind)
  267.         (set-pos-col sexp-ind (pos-col last-ind))))
  268.          ((numberp type)
  269.           ;; first TYPE sexps are indented double
  270.           (right-char (if (<= index type)
  271.                   (* 2 lisp-body-indent)
  272.                 lisp-body-indent)
  273.               sexp-ind)))))))
  274.     sexp-ind))
  275.  
  276. ;; Set up indentation hints
  277.  
  278. (put 'let 'lisp-indent 1)
  279. (put 'let* 'lisp-indent 1)
  280. (put 'if 'lisp-indent 2)
  281. (put 'when 'lisp-indent 1)
  282. (put 'unless 'lisp-indent 1)
  283. (put 'while 'lisp-indent 1)
  284. (put 'lambda 'lisp-indent 'defun)
  285. (put 'defun 'lisp-indent 'defun)
  286. (put 'defmacro 'lisp-indent 'defun)
  287. (put 'defvar 'lisp-indent 'defun)
  288. (put 'defconst 'lisp-indent 'defun)
  289. (put 'progn 'lisp-indent 0)
  290. (put 'prog1 'lisp-indent 1)
  291. (put 'prog2 'lisp-indent 2)
  292. (put 'unwind-protect 'lisp-indent 1)
  293. (put 'error-protect 'lisp-indent 1)
  294. (put 'with-buffer 'lisp-indent 1)
  295. (put 'with-window 'lisp-indent 1)
  296. (put 'catch 'lisp-indent 1)
  297. (put 'bind-keys 'lisp-indent 1)
  298. (put 'unbind-keys 'lisp-indent 1)
  299.